.md # Εξέλιξη πολιτικών σχηματισμών
:::info
Συγγραφή: *Κώστας Κούδας*
Υλοποίηση μέσω γλώσσας Wolfram στο [WLJS Notebook](https://jerryi.github.io/wljs-docs/).
:::
:::warning
⚠️ ΥΠΟ ΚΑΤΑΣΚΕΥΗ ⚠️
:::
## Μανιχαϊστικό μοντέλο
Έστω ότι τη χρονική στιγμή `t` το αναμενόμενο πλήθος αριστερών είναι `aristeroi[t]` και των δεξιών `dexioi[t]`.
Θεωρούμε ότι το παιδί ενός αριστερού παραμένει αριστερό με κάποια πιθανότητα ή γίνεται δεξιό με κάποια άλλη πιθνότητα. Συγκεκριμένα, θεωρούμε πως αν υπάρχουν μόνο αριστεροί στην κοινωνία, τότε η πιθανότητα κάποιος αριστερός να κάνει δεξιό παιδί είναι `a0`. Από την άλλη, αν δεν υπάρχουν σχεδόν καθόλου αριστεροί, το να παραμείνει αριστερό ένα παιδί αριστερού έχει πιθανότητα `a1`. Ή, με άλλα λόγια, θα γίνει δεξιό με πιθανότητα `1-a1`. Για τις ενδιάμεσες περιπτώσεις θεωρούμε πως η πιθανότητα να γίνει δεξιό το παιδί αριστερού είναι κάτι ενδιάμεσο των `a0` και `1-a1`. Για την ακρίβεια, θεωρούμε πως κάθε ποσοστιαία αύξιση των δεξιών επιφέρει ανάλογη αύξηση της πιθανότητας το παιδί να γίνει δεξιό. Έτσι, τη χρονική στιγμή `t` η πιθανότητα ένα παιδί αριστερού να γίνει δεξιό θα είναι `a0+(1-a1-a0)dexioi[t]/(aristeroi[t]+dexioi[t])`. Με απλές πράξεις προκύπτει ότι τη χρονική στιγμή `t` η πιθανότητα ένα παιδί αριστερού να παραμείνει αριστερό είναι `1-a0+(a1-1+a0)dexioi[t]/(aristeroi[t]+dexioi[t])`.
Με την ίδια λογική έχουμε ότι η πιθανότητα ένα παιδί δεξιού να γίνει αριστερό είναι `d0+(1-d1-d0)aristeroi[t]/(aristeroi[t]+dexioi[t])`, ενώ η πιθανότητα να παραμείνει δεξιό είναι `1-d0+(d1-1+d0)aristeroi[t]/(aristeroi[t]+dexioi[t])`.
Συνεπώς, αν κάθε άνθρωπος κάνει `c` παιδιά, τότε ο αναμενόμενος αρθμός αριστερών τη χρονική στιγμή `t+1` θα είναι:
`(1-a0+(a1-1+a0)dexioi[t]/(aristeroi[t]+dexioi[t]))*c*aristeroi[t]+(d0+(1-d1-d0)aristeroi[t]/(aristeroi[t]+dexioi[t]))*c*dexioi[t]`,
ενώ ο αναμενόμενος αριθμός δεξιών θα είναι:
`(a0+(1-a1-a0)dexioi[t]/(aristeroi[t]+dexioi[t]))*c*aristeroi[t]+(1-d0+(d1-1+d0)aristeroi[t]/(aristeroi[t]+dexioi[t]))*c*dexioi[t]`.
Επομένως έχουμε τις κάτωθι εξισώσεις:
Εξέλιξη πολιτικών σχηματισμών
Μανιχαϊστικό μοντέλο
Clear["Global`*"]
c=2;
a0=0.1;
a1=0.3;
d0=0.2;
d1=0.1;
aristeroi[0]=10000;
dexioi[0]=90000;
aristeroi[n_] := aristeroi[n] = (1-a0+(a1-1+a0)dexioi[n-1]/(aristeroi[n-1]+dexioi[n-1]))*c*aristeroi[n-1]+(d0+(1-d1-d0)aristeroi[n-1]/(aristeroi[n-1]+dexioi[n-1]))*c*dexioi[n-1]
dexioi[n_] := dexioi[n] =(a0+(1-a1-a0)dexioi[n-1]/(aristeroi[n-1]+dexioi[n-1]))*c*aristeroi[n-1]+(1-d0+(d1-1+d0)aristeroi[n-1]/(aristeroi[n-1]+dexioi[n-1]))*c*dexioi[n-1]
aProp = Table[aristeroi[n]/(aristeroi[n]+dexioi[n]),{n,0,50}];
ListPlot[aProp]
(* Υπολογισμός των διανυσμάτων *)
listAB = Table[{aristeroi[n]/(aristeroi[n]+dexioi[n]), dexioi[n]/(aristeroi[n]+dexioi[n])}, {n, 0, 55}];
vectors = Table[
listAB[[n + 1]] - listAB[[n]],
{n, 1, Length[listAB] - 1}];
(* Συνδυασμός αρχικών σημείων και διανυσμάτων *)
vectorData = Table[
{listAB[[n]], vectors[[n]]},
{n, 1, Length[vectors]}];
(* Χρήση ListVectorPlot *)
pl=ListVectorPlot[vectorData, VectorPoints -> All, PlotLegends->Automatic]
Clear["Global`*"]
c=2;
a0=0.1;
a1=0.3;
d0=0.2;
d1=0.1;
aristeroi[n_] := aristeroi[n] = (1-a0+(a1-1+a0)dexioi[n-1]/(aristeroi[n-1]+dexioi[n-1]))*c*aristeroi[n-1]+(d0+(1-d1-d0)aristeroi[n-1]/(aristeroi[n-1]+dexioi[n-1]))*c*dexioi[n-1]
dexioi[n_] := dexioi[n] =(a0+(1-a1-a0)dexioi[n-1]/(aristeroi[n-1]+dexioi[n-1]))*c*aristeroi[n-1]+(1-d0+(d1-1+d0)aristeroi[n-1]/(aristeroi[n-1]+dexioi[n-1]))*c*dexioi[n-1]
aristeroi[0]=10;
dexioi[0]=60;
(* Δημιουργία της λίστας με τα σημεία *)
listAB = Table[{aristeroi[n]/(aristeroi[n]+dexioi[n]), dexioi[n]/(aristeroi[n]+dexioi[n])}, {n, 0, 20}];
(* Δημιουργία των βελών *)
arrows = Table[
Arrow[{listAB[[n]], listAB[[n + 1]]}], {n, 1, Length[listAB] - 1}];
(* Απεικόνιση των βελών *)
Graphics[arrows, Axes -> True, AspectRatio -> 1]
Clear["Global`*"]
c=2;
a0=1/10;
a1=3/10;
d0=2/10;
d1=1/10;
ar2 = (1-a0+(a1-1+a0)d/(a+d))*c*a+(d0+(1-d1-d0)a/(a+d))*c*d;
de2 = (a0+(1-a1-a0)d/(a+d))*c*a+(1-d0+(d1-1+d0)a/(a+d))*c*d;
eqA = ar2/(ar2+de2)-a/(a+d)==0
eqD = de2/(ar2+de2)-d/(a+d)==0
Solve[{eqA,eqD},{a,d}]//N
Together[eqA[[1]]]
Together[eqD[[1]]]
ContourPlot[{eqA,eqD}, {a, -0.5,0.5}, {d, -0.5,0.5}]
Clear["Global`*"]
c=2;
a0=1/10;
a1=3/10;
d0=2/10;
d1=1/10;
eqA = ((1-a0)*(a+d)+(a1-1+a0)d)*c*a+(d0*(a+d)+(1-d1-d0)a)*c*d==a(a+d)
eqD = (a0*(a+d)+(1-a1-a0)d)*c*a+((1-d0)*(a+d)+(d1-1+d0)a)*c*d==d(a+d)
Assuming[a>0,Solve[{eqA,eqD},{a,d}]]
Together[((1-a0)*(a+d)+(a1-1+a0)d)*c*a+(d0*(a+d)+(1-d1-d0)a)*c*d-a(a+d)]
.md ## Μοντέλο με διώξεις
Μοντέλο με διώξεις
.md ## Ύπαρξη κέντρου
Ύπαρξη κέντρου
.md Αυτό το μοντέλο θα είναι ίδιο με το αρχικό, μόνο που στην ανδεχόμενη μετάβαση από αριστερά στα δεξιά μεσολαβεί το κέντρο.